home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / bindings.tcl.z / bindings.tcl
Text File  |  2002-07-08  |  9KB  |  292 lines
  1. # bindings.tcl
  2. #
  3. # Keystroke bindings
  4. #
  5. # Copyright (c) 1993 Xerox Corporation.
  6. # Use and copying of this software and preparation of derivative works based
  7. # upon this software are permitted. Any distribution of this software or
  8. # derivative works must comply with all applicable United States export
  9. # control laws. This software is made available AS IS, and Xerox Corporation
  10. # makes no warranty about the software, its performance or its conformity to
  11. # any specification.
  12.  
  13. proc Bindings_Main { w } {
  14.     # Keystroke bindings for operations on messages and folders
  15.     # Assert $w == $exwin(mtext)
  16.     global bindings
  17.     catch {unset bindings}
  18.     set bindings(dotfile) ~/.exmh/exmhbindings
  19.     BindingsReadPref
  20.     BindingsReset $w
  21. }
  22. proc BindingsReset { w } {
  23.     global bindings
  24.     bindtags $w [list TSelect TScroll Command $w all]
  25.     set w Command
  26.     bind $w <Any-Key> {if {"%A" != "{}"} {Exmh_Status "bad key %A"} }
  27.     Bind_Key $w <Control-Return>     {Folder_Commit}
  28.     Bind_Key $w <Key-A> {MimeSunAppSelection}
  29.     Bind_Key $w <Key-i> {Inc}
  30.     Bind_Key $w <Key-c> {Msg_Compose}
  31.     Bind_Key $w <Key-C> {Msg_CompSel}
  32.     Bind_Key $w <Key-d> {Msg_Remove}
  33.     Bind_Key $w <Key-D> {Msg_RemoveNoshow}
  34.     Bind_Key $w <Key-g> {URI_OpenSelection}
  35.     Bind_Key $w <Key-z> {URI_ScanMsg {} $uri(scanLimit)}
  36.     Bind_Key $w <Key-p> {Ftoc_Prev show}
  37.     Bind_Key $w <Key-P> {Ftoc_Prev noshow}
  38.     Bind_Key $w <minus> {Ftoc_PrevMarked}
  39.     Bind_Key $w <Key-n> {Ftoc_Next show}
  40.     Bind_Key $w <Key-N> {Ftoc_Next noshow}
  41.     Bind_Key $w <Key-m> {Msg_Move}
  42.     Bind_Key $w <Key-M> {Msg_MoveNoshow}
  43.     Bind_Key $w <Key-r> {Msg_Reply -nocc to -nocc cc}
  44.     Bind_Key $w <Key-R> {Msg_Reply -cc to -cc cc}
  45.     Bind_Key $w <Key-f> {Msg_Forward}
  46.     Bind_Key $w <Key-F> {Folder_Unseen}
  47.     Bind_Key $w <Key-s> {Msg_ShowCurrent}
  48.     Bind_Key $w <Key-u> {Ftoc_Unmark}
  49.     Bind_Key $w <Key-U> {Msg_ShowUnseen}
  50.     Bind_Key $w <asciicircum> {Msg_First}
  51.     Bind_Key $w <dollar> {Msg_Last}
  52.     Bind_Key $w <Control-s> {Find_It forw}
  53.     Bind_Key $w <Control-r> {Find_It prev}
  54.     Bind_Key $w <question> {Bind_Pref}
  55.     Bind_Key $w <period> {Folder_AutoRefile}
  56.     # Page message - the function keys are Sun4 keyboard specific
  57.     Bind_Key $w <space>            {Msg_PageOrNext}
  58.     Bind_Key $w {<BackSpace> <Prior> <F29>}    {Msg_PageUp}
  59.     Bind_Key $w {<Up> <Key-k>}        {Msg_LineUp}
  60.     Bind_Key $w {<Next> <F35>}        {Msg_PageDown}
  61.     Bind_Key $w {<Down> <Key-j>}    {Msg_LineDown}
  62.     Bind_Key $w {<Home> <Key-less>}    {Msg_Top}
  63.     Bind_Key $w {<End> <Key-greater>}    {Msg_Bottom}
  64.     # Page Ftoc
  65.     Bind_Key $w {<Control-n> <Shift-Next>}  {Ftoc_PageDown}
  66.     Bind_Key $w {<Control-p> <Shift-Prior>} {Ftoc_PageUp}
  67.     #
  68.     Bind_Key $w <Control-w>    {Msg_CopySelection}
  69.  
  70.     Select_Bindings $w    ;# Keyboard selection of folders
  71.     Addr_Bindings $w    ;# Address book bindings.
  72.  
  73.     if {[info command User_Bindings] != ""} {
  74.     User_Bindings $w
  75.     }
  76.     foreach item [array names bindings] {
  77.     if [regexp ^key $item match] {
  78.         set cmd [lindex [split $item ,] 1]
  79.         # This will just install any extras from the users .exmhbindings
  80.         Bind_Key $w {} $cmd 
  81.     }
  82.     }
  83. }
  84.  
  85. proc Bindings_Search { entry } {
  86.     # Bindings for the search entry widget
  87.     Widget_BindEntryCmd $entry <Return> { Find_It }
  88.     Widget_BindEntryCmd $entry <Control-r> { Find_It prev }
  89.     Widget_BindEntryCmd $entry <Control-s> { Find_It forw }
  90. }
  91.  
  92. proc UserCommitAction { } {
  93.     global bind
  94.     if [info exists bind(commitAction)] {
  95.     if [eval $bind(commitAction)] {
  96.         unset bind(commitAction)
  97.     }
  98.     }
  99. }
  100. proc BindOrderReset {} {
  101.     global bindings
  102.     set bindings(order) {}
  103. }
  104. proc Bind_Key { w defaultSeq cmd } {
  105.     global bindings
  106.     if [info exists bindings(key,$cmd)] {
  107.     # Preserve existing key specifications (from ~/.exmh/exmhbindings)
  108.     set seqs $bindings(key,$cmd)
  109.     } else {
  110.     set seqs $defaultSeq
  111.     }
  112.     foreach seq $seqs {
  113.     if [catch {
  114.         if {$seq == {}} {
  115.         continue
  116.         }
  117.         bind $w $seq $cmd
  118.         # Double-bind Meta-key and Escape-key
  119.         if [regexp {<Meta-(.*)>} $seq match letter] {
  120.         bind $w <Escape><$letter> $cmd
  121.         }
  122.         # Make leading keystroke harmless
  123.         if [regexp {(<.+>)<.+>} $seq match prefix] {
  124.         bind $w $prefix { }
  125.         }
  126.         bind $w $seq $cmd
  127.     } err] {
  128.         Exmh_Status "$cmd: $err"
  129.     }
  130.     }
  131.     set bindings(key,$cmd) $seqs
  132.     if {[string length $defaultSeq] != 0} {
  133.     set bindings(default,$cmd) $defaultSeq
  134.     } elseif {! [info exists bindings(default,$cmd)]} {
  135.     set bindings(default,$cmd) {}
  136.     }
  137. }
  138.  
  139. proc Bind_Pref {} {
  140.     global bindings
  141.     if [Exwin_Toplevel .bindpref "Key Commands Preferences" Pref] {
  142.     Widget_Label .bindpref.but label {left fill} \
  143.         -text "Key command bindings"
  144.  
  145.     Widget_AddBut .bindpref.but save "Save" {BindingsPrefSave}
  146.     Widget_AddBut .bindpref.but help "Help" {BindingsPrefHelp}
  147.     set f2 [Widget_Frame .bindpref def Dialog {top fillx}]
  148.     $f2 configure -bd 10
  149.  
  150.     Widget_Frame $f2 cmd Preference {top fillx}
  151.     Widget_Label $f2.cmd label {left} -text Command -width 10 -anchor w
  152.     Widget_Entry $f2.cmd entry {right expand fillx} -width 30
  153.  
  154.     Widget_Frame $f2 key Preference {top fillx}
  155.     Widget_Label $f2.key label {left} -text Key -width 10 -anchor w
  156.     Widget_Entry $f2.key entry {left expand fillx} -width 30
  157.     
  158.     set cmdEntry $f2.cmd.entry
  159.     set keyEntry $f2.key.entry
  160.     bind $cmdEntry <Tab> [list focus $keyEntry]
  161.     bind $keyEntry <Return> [list BindingsDefine $cmdEntry $keyEntry]
  162.     set doit [button $f2.key.doit -text Define \
  163.         -command [list BindingsDefine $cmdEntry $keyEntry]]
  164.     pack $doit -side left
  165.  
  166.     set f [Widget_Frame .bindpref c ScrollCanvas]
  167.  
  168.     canvas $f.can -width 500 -height 300 \
  169.         -yscrollcommand [list $f.scroll set] \
  170.         -scrollregion "0 0 500 300"
  171.     wm minsize .bindpref 300 200
  172.     scrollbar $f.scroll -command [list $f.can yview] -orient vertical
  173.     pack $f.scroll -side right -fill y
  174.     pack $f.can -side left -fill both -expand true
  175.     BindPrefDisplay .bindpref.c.can
  176.     }
  177.     focus .bindpref.def.cmd
  178. }
  179. proc BindingsPrefHelp {} {
  180.     Help Bindings "Command Bindings Help"
  181. }
  182. proc BindPrefDisplay { canvas } {
  183.     global bindings
  184.     set width 0
  185.     foreach item [array names bindings] {
  186.     if [regexp ^key $item] {
  187.         set name [lindex [split $item ,] 1]
  188.         set w [string length $name]
  189.         if {$w > $width} { set width $w }
  190.         set map($name) $bindings($item)
  191.     }
  192.     }
  193.     set size 0
  194.     if {$width > 50} {
  195.     set width 50
  196.     }
  197.     catch {destroy $canvas.f}
  198.     frame $canvas.f
  199.     $canvas create window 5 0 -anchor nw -window $canvas.f
  200.     foreach name [lsort -command BindPrefSort [array names map]] {
  201.     set keystroke $map($name)
  202.     incr size
  203.     BindingsPrefItem $canvas.f $width $name action$size $keystroke
  204.     if {[string length $keystroke] == 0} {
  205.         pack forget $canvas.f.action$size
  206.     }
  207.     }
  208.     set child [lindex [pack slaves $canvas.f] 0]
  209.     Visibility_Wait $child
  210.     $canvas config -scrollregion "0 0 [winfo width $canvas.f] [winfo height $canvas.f]"
  211. }
  212. proc BindPrefSort {s1 s2} {
  213.     string compare [string tolower $s1] [string tolower $s2]
  214. }
  215. proc BindingsPrefItem { frame width cmd name keystroke } {
  216.     global bindings
  217.     Widget_Frame $frame $name Preference
  218.     set label [string range $cmd 0 [expr $width-1]]
  219.     Widget_Label $frame.$name label {left} -text $label -width $width -anchor w
  220.     Widget_Entry $frame.$name entry {right expand fill} -width 30
  221.     set bindings(entry,$cmd) $frame.$name.entry
  222.     $frame.$name.entry insert 0 $keystroke
  223.     Widget_BindEntryCmd $frame.$name.entry <Return> [list BindRebind $cmd]
  224. }
  225. proc BindingsPrefSave { } {
  226.     global bindings
  227.     # Save it
  228.     set out [open $bindings(dotfile) w]
  229.     foreach item [array names bindings] {
  230.     if [regexp ^key $item match] {
  231.         set name [lindex [split $item ,] 1]
  232.         set entry $bindings(entry,$name)
  233.         set keystrokes [$entry get]
  234.         if {[catch {set bindings(default,$name)} default] == 0} {
  235.         if {[string compare $default $keystrokes] == 0} {
  236.             # Don't save settings that are system defaults
  237.             # Because default for user-defined things is NULL, this
  238.             # also means you can delete user-defined bindings by
  239.             # clearing their binding string.
  240.             continue
  241.         }
  242.         }
  243.         puts $out [list set bindings($match,$name) $keystrokes]
  244.     }
  245.     }
  246.     close $out
  247.     Exwin_Dismiss .bindpref
  248.     # Apply it to current session
  249.     global exwin
  250.     BindingsReset $exwin(mtext)
  251. }
  252.  
  253. proc BindingsReadPref {} {
  254.     global bindings
  255.     if [file exists $bindings(dotfile)] {
  256.     if [catch {uplevel #0 source [glob $bindings(dotfile)]} msg] {
  257.         Exmh_Status "Error in $bindings(dotfile): $msg"
  258.         return
  259.     } 
  260.     }
  261. }
  262.  
  263. proc BindingsDefine { cmdEntry keyEntry } {
  264.     set cmd [$cmdEntry get]
  265.     set key [$keyEntry get]
  266.     Exmh_Status "Bind $key => $cmd"
  267.     BindingsDefineInner $cmd $key
  268. }
  269. proc BindRebind { cmd } {
  270.     global bindings
  271.     set key [$bindings(entry,$cmd) get]
  272.     Exmh_Status "Bind $key => $cmd"
  273.     BindingsDefineInner $cmd $key
  274. }
  275. proc BindingsDefineInner { newcmd key } {
  276.     global bindings exwin
  277.     #
  278.     # Make sure we get any unsaved changes to other entries
  279.     #
  280.     foreach item [array names bindings] {
  281.     if {[string match entry,* $item]} {
  282.         set cmd [lindex [split $item ,] 1]
  283.         set seqs [$bindings(entry,$cmd) get]
  284.         set bindings(key,$cmd) $seqs
  285.     }
  286.     }
  287.     # But override a change from the main entires
  288.     set bindings(key,$newcmd) $key
  289.     BindingsReset $exwin(mtext)    ;# clear and reset everything
  290.     BindPrefDisplay .bindpref.c.can
  291. }
  292.